home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 30
/
Aminet 30 (1999)(Schatztruhe)[!][Apr 1999].iso
/
Aminet
/
util
/
pack
/
xpk_Source.lha
/
xpk_Source
/
Oberon
/
examples
/
xpk.mod
next >
Wrap
Text File
|
1998-11-09
|
8KB
|
319 lines
(*************************************************************************
:Program. Xpk.mod
:Contents. General XPK file-to-file packer/unpacker
:Author. Hartmut Goebel [hG]
:Language. Oberon
:Translator. Amiga Oberon V2.14
:History. V0.9, 09 Jan 1992 Hartmut Goebel [hG]
:Date. 06 Aug 1992 00:01:50
*************************************************************************)
MODULE Xpk;
IMPORT
NoGuru, io,
arg:= Arguments,
d := Dos,
e := Exec,
ol := OberonLib,
pf := Printf,
s := SYSTEM,
str:= Strings,
u := Utility,
xpk:= XpkMaster;
VAR
argc, c, i: INTEGER;
Arg, Password, Method, NameBuf: e.STRING;
ChunkHook: u.Hook;
suffix, force, unpack, recurse, error: BOOLEAN;
tags: u.Tags8;
ErrBuf: ARRAY xpk.errMsgSize+1 OF CHAR;
BaseName: ARRAY 40 OF CHAR;
CONST
a5 = 13;
Usage = "Usage: XPK [-frsu] [-p password] [-m method] files\n"
" -m = four letter packing method name\n"
" -f = force packing of already packed files\n"
" -s = add suffix and don't delete original\n"
" -r = recursively (un)pack files in dir\n"
" -u = unpack files\n"
" -p = encrypt/decrypt using password";
pTags = u.Tags8(
xpk.inName, NIL,
xpk.outName, NIL,
xpk.chunkHook, NIL,
xpk.getError, NIL,
xpk.findMethod, NIL,
xpk.password, NIL,
xpk.noClobber, e.true,
u.done,0);
tInName = 0; tOutName = 1; tChunkHook = 2; tGetError = 3;
tFindMethod = 4; tPassword = 5; tNoClobber = 6;
TYPE
DirEntryPtr = POINTER TO DirEntry;
DirEntry = STRUCT
next: DirEntryPtr;
name: ARRAY 120 OF CHAR;
END;
PROCEDURE End(text: ARRAY OF CHAR);
BEGIN
io.WriteString(text); io.WriteLn;
HALT(10);
END End;
PROCEDURE ChunkFunc*(myHook{8}: u.HookPtr;
object{10}: e.APTR;
message{9}: e.APTR): LONGINT;
(* $SaveRegs+ Don't know if we need it, but nothing to loose *)
VAR
prog: xpk.XpkProgressPtr;
BEGIN
(* $IF SmallData *)
s.SETREG(a5,myHook.data); (* We need the pointer to the global vars in A5 *)
(* $END *)
prog := message;
IF prog.type = xpk.progStart THEN
pf.Printf0("\033[0 p"); END;
IF prog.type # xpk.progEnd THEN
pf.Printf6("\r%4s: %-8s (%3ld%% done, %2ld%% CF, %6ld cps) %s\033[K",
prog.packerName, prog.activity, prog.done,
prog.cf, prog.speed, prog.fileName);
ELSE
pf.Printf6("\r%4s: %-8s (%3ldK, %2ld%% CF, %6ld cps) %s\033[K\n",
prog.packerName, prog.activity, prog.uLen DIV 1024,
prog.cf, prog.speed, prog.fileName);
END;
IF prog.type = xpk.progEnd THEN
pf.Printf0("\033[1 p"); END;
RETURN s.VAL(LONGINT,e.SetSignal(LONGSET{},LONGSET{d.ctrlC}) * LONGSET{d.ctrlC});
END ChunkFunc;
PROCEDURE GetBaseName(name: ARRAY OF CHAR);
VAR
ret, len: INTEGER;
BEGIN
len := 0; ret := 0;
WHILE name[len] # CHR(0) DO
CASE name[len] OF "/", ":": ret := len+1; ELSE END;
INC(len);
END;
str.Cut(name,ret,SIZE(BaseName),BaseName);
str.Upper(BaseName);
END GetBaseName;
PROCEDURE TempName(VAR name: ARRAY OF CHAR);
VAR
ret, len: INTEGER;
BEGIN
COPY(name,NameBuf);
len := str.Length(name);
LOOP
IF len <= 0 THEN EXIT; END;
DEC(len);
CASE name[len] OF "/", ":": EXIT; ELSE END;
END;
CASE name[len] OF "/", ":": INC(len); ELSE END;
name[len] := CHR(0);
pf.SPrintf1(name,"tmp%lx",s.ADR(name));
END TempName;
PROCEDURE DoFile(filename: ARRAY OF CHAR): BOOLEAN;
VAR
fib: xpk.XpkFib;
buf: ARRAY 100 OF CHAR;
len: INTEGER;
help: ARRAY 6 OF CHAR;
BEGIN
IF ~force OR unpack THEN
IF xpk.ExamineTags(fib,xpk.inName,s.ADR(filename),u.done) # 0 THEN
io.WriteString("Error examining "); io.WriteString(filename); io.WriteLn;
RETURN FALSE;
END;
END;
TempName(filename);
IF ~unpack THEN
IF ~force & (fib.type # xpk.typeUnpacked) THEN
io.WriteString("Skipping (already packed) ");
io.WriteString(filename); io.WriteLn;
RETURN FALSE;
END;
IF suffix THEN
pf.SPrintf1( NameBuf, "%s.xpk", s.ADR(filename)); END;
IF xpk.Pack(tags) # 0 THEN
RETURN FALSE; END;
ELSE
IF fib.type # xpk.typePacked THEN
io.WriteString("Skipping (already unpacked) ");
io.WriteString(filename); io.WriteLn;
RETURN FALSE;
END;
len := str.Length(filename);
suffix:=FALSE;
str.Cut(filename,len-5,5,help); str.Upper(help);
IF (len>4) & (help = ".XPK") THEN
COPY(NameBuf,filename);
NameBuf[len-5]:=CHR(0);
suffix:=TRUE;
END;
IF xpk.Unpack(tags) # 0 THEN
RETURN FALSE; END;
END;
IF ~suffix THEN
IF ~d.DeleteFile(filename) THEN
ErrBuf := "Cannot delete input file";
RETURN FALSE;
END;
IF ~d.Rename(NameBuf,filename) THEN
ErrBuf := "Cannot rename tempfile";
RETURN FALSE;
END;
END;
END DoFile;
PROCEDURE DoArg(name: ARRAY OF CHAR);
VAR
fr, entry: DirEntryPtr;
lock, prev: d.FileLockPtr;
buf: ARRAY 200 OF CHAR;
fib: d.FileInfoBlockPtr;
root: DirEntry;
BEGIN
NEW(fib);
IF fib = NIL THEN
ErrBuf:="Out of memory"; error := TRUE;
RETURN;
END;
lock := d.Lock(name, d.accessRead);
IF lock = NIL THEN
pf.SPrintf2(ErrBuf,"Error %d reading %s",d.IoErr(),s.ADR(name));
error := TRUE;
RETURN;
END;
IF ~d.Examine( lock, fib^) THEN
d.UnLock( lock );
pf.SPrintf2(ErrBuf,"Error %d reading %s",d.IoErr(),s.ADR(name));
error := TRUE;
RETURN;
END;
IF fib.dirEntryType<0 THEN
d.UnLock(lock);
IF ~DoFile(fib.fileName) THEN error := TRUE; END;
ELSIF recurse THEN
io.WriteString("Directory "); io.WriteString(name); io.WriteLn;
prev:=d.CurrentDir(lock);
entry:=s.ADR(root);
WHILE d.ExNext(lock,fib^) & ~error DO
IF d.ctrlC IN e.SetSignal(LONGSET{},LONGSET{d.ctrlC}) THEN
ErrBuf:=" *** Break"; error := TRUE;
ELSE
NEW(entry.next);
IF entry.next = NIL THEN
ErrBuf:="Out of memory"; error := TRUE;
ELSE
entry:=entry.next;
COPY(fib.fileName,entry.name);
END;
END;
END;
entry.next:= NIL;
entry := root.next;
WHILE entry # NIL DO
DoArg(entry.name);
fr:=entry; entry := entry.next; DISPOSE(fr);
END;
d.UnLock(d.CurrentDir(prev));
io.WriteString("Directory end"); io.WriteString(name); io.WriteLn;
END;
END DoArg;
BEGIN
ChunkHook.entry := ChunkFunc;
(* $IF SmallData *)
ChunkHook.data := s.REG(a5); (* preserve for restore in hook function *)
(* $END *)
tags[tInName].data := s.ADR(Arg);
tags[tOutName].data := s.ADR(NameBuf);
tags[tChunkHook].data := s.ADR(ChunkHook);
tags[tGetError].data := s.ADR(ErrBuf);
tags[tFindMethod].data := s.ADR(Method);
tags[tPassword].data := NIL;
argc := arg.NumArgs(); i := 1;
arg.GetArg(0,Method);
GetBaseName(Method);
arg.GetArg(1,Arg);
IF ((argc <2) OR (Arg = "?")) THEN
End(Usage);
ELSIF (BaseName # "XPK") THEN
COPY(BaseName,Method);
ELSE
Method := "";
END;
WHILE (i <= argc) & (Arg[0]="-") DO
c := 1;
WHILE Arg[c] # CHR(0) DO
CASE Arg[c] OF
'p': INC(i); arg.GetArg(i,Password); tags[tPassword].data := s.ADR(Password); |
'm': INC(i); arg.GetArg(i,Method); |
's': suffix := TRUE; |
'f': force := TRUE; |
'u': unpack := TRUE; tags[tFindMethod].tag := u.ignore; |
'r': recurse := TRUE; |
ELSE
End(Usage);
END;
INC(c);
END;
INC(i); arg.GetArg(i,Arg);
END;
IF i > argc THEN End(Usage); END;
IF (Method="") & ~unpack THEN
End("Need a packing method, use -m"); END;
WHILE (i <= argc) & ~error DO
arg.GetArg(i,Arg);
DoArg(Arg);
INC(i);
END;
IF error THEN End(ErrBuf); END;
END Xpk.